home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir30 / heaven_1.zip / DDALIAS.LSP < prev    next >
Lisp/Scheme  |  1993-11-01  |  17KB  |  495 lines
  1. ;;╔══════════════════════════════════════════════════════════════════════════╗
  2. ;;║Program name:       DDALIAS.LSP                                           ║
  3. ;;║Initial Author:     Michael Jenkins @ Gray Construction Company           ║
  4. ;;║Description:        This is a dialog box for creating command aliases     ║
  5. ;;║                    within AutoCAD. This routine actually evaluates the   ║
  6. ;;║                    existing PGP file and will build a new one based on   ║
  7. ;;║                    the users input. This allows the user to assign       ║
  8. ;;║                    aliases on the fly without editing the ACAD.PGP file. ║
  9. ;;╚══════════════════════════════════════════════════════════════════════════╝
  10. ;;========================== Load-time error checking ========================
  11. (defun ai_abort(app msg)
  12.    (defun *error*(s)
  13.       (if old_error(setq *error* old_error))
  14.       (princ)
  15.    ) ;defun *error*
  16.    (if msg               
  17.       (alert(strcat " Application error: "app" \n\n  "msg"  \n"))
  18.    ) ;if
  19.    (exit)
  20. ) ;defun
  21. ;;
  22. ;;Check to see if AI_UTILS is loaded, If not, try to find it, and then try  
  23. ;;to load it. If it can't be found or it can't be loaded, then abort the    
  24. ;;loading of this file immediately, preserving the (autoload) stub function.
  25. ;;
  26. (cond
  27.    ((and ai_dcl(listp ai_dcl)))            ; it's already loaded.
  28.    ((not(findfile "ai_utils.lsp"))         ; find it
  29.       (ai_abort func_name
  30.          (strcat "Can't locate file AI_UTILS.LSP.")
  31.       ) ;ai_abort
  32.    ) ;not
  33.    ((eq "failed"(load "ai_utils" "failed")); load it
  34.    (ai_abort func_name "Can't load file AI_UTILS.LSP"))
  35. ) ;cond
  36. ;;
  37. ;;If acad_app is loaded
  38. ;;
  39.  
  40. (if(not(ai_acadapp))           
  41.    (ai_abort func_name nil)    
  42. ) ;if                          
  43. ;;======================== End load-time error checking ======================
  44.  
  45. (defun c:ddalias (/ list_pair index command_list)
  46.      ;;
  47.      ;;                            ┌── Change this to reflect the full path
  48.      ;;                            │     to your ACAD.PGP file.
  49.      ;;             ┌──────────────┴────────────┐
  50.      ;;             │                           │
  51.      (setq pgp_name "c:/acadr12/support/acad.pgp")
  52.    ;;
  53.  
  54.       (setq cmdecho (getvar "cmdecho"))
  55.    (setvar "cmdecho" 0)
  56.  
  57.      ;error handler
  58.      (setq *olderror* *error*)
  59.      (defun *error* (msg)
  60.         (princ msg)
  61.             (if cmdecho (setvar "cmdecho" cmdecho))
  62.             (setq *error* *olderror*)
  63.             (princ)
  64.      )
  65.  
  66.    ;; This function takes a string and a delimiter and returns
  67.    ;; the parsed strings as a list.
  68.    ;;
  69.    (defun _parsestr (string del / count return gp)
  70.       (if (/= string "")
  71.          (progn
  72.             (setq
  73.                count 1
  74.                return '()
  75.                string (strcat string del)
  76.                new_string ""
  77.             )
  78.             (while (< count (1+ (strlen string)))
  79.                (if (= (substr string count 1) del)
  80.                   (progn
  81.                      (setq return (append return (list new_string)))
  82.                      (setq new_string "")
  83.                   )
  84.                   (setq new_string (strcat new_string (substr string count 1)))
  85.                )
  86.                (setq count (1+ count))
  87.             )     
  88.             return
  89.          ) 
  90.          nil
  91.       )   
  92.    )
  93.  
  94.    ;;
  95.    ;; This function checks the input box for illegal characters 
  96.    ;; and duplicate aliases
  97.    ;;
  98.    (defun _good (alias / alias good_pos)
  99.       (setq
  100.          good_pos 1
  101.          gp 0
  102.       )
  103.       ;check for illegal characters in the text input box
  104.       (while (< good_pos (1+ (strlen alias)))
  105.          (if
  106.             (not
  107.                (member
  108.                   (strcase (substr alias good_pos 1))
  109.                   '(
  110.                      "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M"
  111.                      "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
  112.                      "1" "2" "3" "4" "5" "6" "7" "8" "9" "0" ","
  113.                   )
  114.                )
  115.             )  
  116.             (setq
  117.                good_pos (1+ (strlen alias))
  118.                gp 1                        
  119.             )
  120.          )
  121.          (setq good_pos (1+ good_pos))
  122.       )
  123.       ;check for duplicate aliases
  124.       (if (and (/= alias "") (/= gp 1))
  125.          (foreach n (_parsestr (strcase alias) ",")
  126.             (foreach cmd list_pair
  127.                (foreach al (_parsestr (strcase (cdr cmd)) ",")
  128.                   (if (= al n)
  129.                      (if (/= (nth index command_list) (car cmd))
  130.                         (setq gp (car cmd))
  131.                      )   
  132.                   )
  133.                )
  134.             )
  135.          )
  136.       )
  137.       gp
  138.    )
  139.  
  140.    ;process the pop-up list
  141.    (defun _command ()
  142.       (setq is_it_good (_good (get_tile "alias")))
  143.       (cond ((= is_it_good 0)
  144.             (_change)
  145.             (setq index (atoi (get_tile "command")))
  146.             (_update)
  147.             (set_tile "error" "")
  148.          )
  149.          ((= is_it_good 1)
  150.             (set_tile "error" "Empty or Invalid Input")
  151.             (set_tile "command" (itoa index))
  152.             (mode_tile "alias" 2)
  153.          )
  154.          (T
  155.             (set_tile "error" (strcat "Duplicate Alias Found in " (strcase is_it_good)))
  156.             (set_tile "command" (itoa index))
  157.             (mode_tile "alias" 2)
  158.          )
  159.       )   
  160.       is_it_good
  161.    )   
  162.  
  163.    ;change the value in the list
  164.    (defun _change ()
  165.       (if (assoc (nth index command_list) list_pair)
  166.          (setq list_pair
  167.             (subst
  168.                (cons (nth index command_list) (get_tile "alias"))
  169.                (assoc (nth index command_list) list_pair)
  170.                list_pair
  171.             )
  172.          )
  173.          (setq 
  174.             list_pair
  175.             (append
  176.                (list (cons (nth index command_list) (get_tile "alias")))
  177.                list_pair
  178.             )
  179.          )
  180.       )
  181.    )
  182.  
  183.    ;clear the value to empty string
  184.    (defun _clear ()
  185.       (setq list_pair
  186.          (subst
  187.             (cons newline "")
  188.             (assoc newline list_pair)
  189.             list_pair
  190.          )
  191.       )
  192.    )
  193.  
  194.    ;update the alias box
  195.    (defun _update ()
  196.       (set_tile "alias" (_getalias (nth index command_list)))
  197.    )   
  198.  
  199.    ;step thru the existing pgp file
  200.    (defun _stepthru ()
  201.       (if 
  202.          (setq
  203.             pgp 
  204.             (open pgp_name "r")
  205.          )
  206.          (progn
  207.             (setq list_pair nil)
  208.             (while
  209.                (/= (setq line (read-line pgp)) nil)
  210.                (setq pos 1)
  211.                (setq comma 0)
  212.                ;check to see if it is an alias
  213.                (while (/= (setq char (substr line pos 1)) "")
  214.                   (cond
  215.                      ((= char ";")
  216.                         (setq pos (+ (strlen line) 1))
  217.                      )
  218.                      ((= char ",")
  219.                         (setq comma (1+ comma))
  220.                      )
  221.                   )
  222.                   (setq pos (1+ pos))
  223.                )         
  224.                ;append it to the list if it is
  225.                (if (= comma 1)
  226.                   (progn
  227.                      (setq pos 1)
  228.                      (setq string "")
  229.                      (while (/= (setq char (substr line pos 1)) ",")
  230.                         (setq string (strcat string char))
  231.                         (setq pos (1+ pos))
  232.                      )
  233.                      (setq line (_ltrim (substr line (1+ pos))))
  234.                      (if (assoc line list_pair)     
  235.                         (setq list_pair
  236.                            (subst
  237.                               (cons line (strcat (cdr (assoc line list_pair)) "," string))
  238.                               (assoc line list_pair)
  239.                               list_pair
  240.                            )
  241.                         )
  242.                         (setq list_pair (_addlist line string))
  243.                      )
  244.                   )    
  245.                )
  246.             )
  247.             (close pgp)
  248.          )
  249.       )
  250.    )  
  251.  
  252.    ;adds an alias to the list
  253.    (defun _addlist (alias command)
  254.       (if (= list_pair nil)
  255.          (list (cons alias command))
  256.          (cons (cons alias command) list_pair)
  257.       )
  258.    )   
  259.  
  260.    ;trims spaces off of the command
  261.    (defun _ltrim (string / string)
  262.       (setq pos 1)
  263.       (while (/= (setq char (substr string pos 1)) "*")
  264.          (setq pos (1+ pos))
  265.       )
  266.       (substr string (1+ pos))
  267.    )      
  268.  
  269.    ;get the alias from the list
  270.    (defun _getalias (command / command)
  271.       (if (assoc command list_pair)
  272.          (cdr (assoc command list_pair))
  273.          ""
  274.       )
  275.    )
  276.  
  277.    ;get all of the commands from the atoms-family
  278.    (defun _addlisp ()
  279.       (foreach cmd (atoms-family 1)
  280.          (if (= (substr cmd 1 2) "C:")
  281.             (setq command_list (append command_list (list (substr cmd 3))))
  282.          )
  283.       )
  284.    )
  285.  
  286.    ;process an okay
  287.    (defun _accept (/ pgpin pgpout pos comma char string newline)
  288.       (if (= (_command) 0)
  289.          (progn
  290.             (set_tile "error" "One Moment Please...")
  291.             (_change)
  292.             (setq
  293.                pgpin (open pgp_name "r")
  294.                file_list nil
  295.             )
  296.             (if pgpin
  297.                (progn
  298.                   (while
  299.                      (/= (setq line (read-line pgpin)) nil)
  300.                      (setq pos 1)
  301.                      (setq comma 0)
  302.                      ;check to see if it is an alias
  303.                      (while (/= (setq char (substr line pos 1)) "")
  304.                         (cond
  305.                            ((= char ";")
  306.                               (setq pos (+ (strlen line) 1))
  307.                            )
  308.                            ((= char ",")
  309.                               (setq comma (1+ comma))
  310.                            )
  311.                         )
  312.                         (setq pos (1+ pos))
  313.                      )         
  314.                      ;append it to the list if it is
  315.                      (if (= comma 1)
  316.                         (progn
  317.                            (setq pos 1)
  318.                            (setq string "")
  319.                            (while (/= (setq char (substr line pos 1)) ",")
  320.                               (setq string (strcat string char))
  321.                               (setq pos (1+ pos))
  322.                            )      
  323.                            (setq newline (_ltrim (substr line (1+ pos))))
  324.                            (if (assoc newline list_pair)
  325.                               (if (/= (cdr (assoc newline list_pair)) "")
  326.                                  (progn
  327.                                     (setq cmdlist (_parse (cdr (assoc newline list_pair))))
  328.                                     (foreach cmd cmdlist
  329.                                        (_append
  330.                                           (strcat
  331.                                              (strcase cmd)
  332.                                              ",*"
  333.                                              newline
  334.                                           )
  335.                                        )   
  336.                                     )
  337.                                     (_clear) 
  338.                                  )
  339.                               )
  340.                               (_append line)
  341.                            )   
  342.                         )
  343.                         (_append line)
  344.                      )    
  345.                   )
  346.                   (close pgpin)
  347.                )
  348.             )
  349.             (foreach cmnd list_pair 
  350.                (if (/= (cdr cmnd) "")
  351.                   (progn
  352.                      (setq cmdlist (_parse (cdr cmnd)))
  353.                      (foreach cmd cmdlist
  354.                         (_append
  355.                            (strcat
  356.                               (strcase cmd)
  357.                               ",*"
  358.                               (car cmnd)
  359.                            )
  360.                         )
  361.                      )
  362.                   )   
  363.                )      
  364.             )         
  365.             (setq pgpout (open pgp_name "w"))
  366.             (foreach line (reverse file_list)
  367.                (write-line line pgpout)
  368.             )
  369.             (close pgpout)
  370.             (set_tile "error" "")
  371.             (done_dialog)
  372.             (setvar "re-init" 16)
  373.          )
  374.       )
  375.    )  
  376.  
  377.    (defun _parse (string / parse_loc cmd)
  378.       (setq
  379.          parse_loc 1
  380.          cmd_list nil
  381.          cmd ""
  382.       )
  383.       (while (< parse_loc (1+ (strlen string))) 
  384.          (if (/= (substr string parse_loc 1) ",")
  385.             (setq cmd (strcat cmd (substr string parse_loc 1)))
  386.             (progn
  387.                (if (= cmd_list nil)
  388.                   (setq cmd_list (list cmd))
  389.                   (setq cmd_list (append (list cmd) cmd_list))
  390.                )
  391.                (setq cmd "")
  392.             )
  393.          )
  394.          (setq parse_loc (1+ parse_loc))
  395.       )   
  396.       (if (= cmd_list nil)
  397.          (setq cmd_list (list cmd))
  398.          (setq cmd_list (append (list cmd) cmd_list))
  399.       )
  400.       cmd_list
  401.    )
  402.  
  403.    (defun _append (add)
  404.       (if (= file_list nil)
  405.          (setq file_list (list add))
  406.          (setq file_list (append (list add) file_list))
  407.       )
  408.    )   
  409.  
  410.    (defun ddalias_main ()
  411.       ;set up the dialog identification
  412.       (if(not(new_dialog "ddalias" dcl_id))(exit))
  413.       (set_tile "error" "One Moment Please...")
  414.       (start_list "command")
  415.       (add_list "")
  416.       (end_list)
  417.       (setq
  418.          command_list
  419.          '(
  420.             "ABOUT" "APERTURE" "ARC" "AREA" "ARRAY" "ATTDEF"
  421.             "ATTDISP" "ATTEDIT" "ATTEXT" "AUDIT" "BASE" 
  422.             "BLIPMODE" "BLOCK" "BREAK" "BOX" "CHAMFER" "CHANGE"
  423.             "CHPROP" "CIRCLE" "COLOR" "COMPILE" "CONE" "CONFIG" "COPY"
  424.             "DBLIST" "DDATTE" "DDEDIT" "DDEMODES" "DDLMODES" "DDRMODES" 
  425.             "DDUCS" "DELAY" "DIM" "DIM1" "DISH" "DIST" "DIVIDE"
  426.             "DOME" "DONUT" "DRAGMODE" "DTEXT" "DVIEW" "DXBIN" "DXFIN"
  427.             "DXFOUT" "EDGESURF" "ELEV" "ELLIPSE" "END" "ERASE"
  428.             "EXPLODE" "EXTEND" "FILES" "FILL" "FILLET" "FILMROLL"
  429.             "GRAPHSCR" "GRID" "HANDLES" "HATCH" "HELP" "HIDE" "ID"
  430.             "IGESIN" "IGESOUT" "INSERT" "ISOPLANE" "LAYER" "LIMITS"
  431.             "LINE" "LINETYPE" "LIST" "LOAD" "LTSCALE" "MEASURE" "MENU" "MESH"
  432.             "MINSERT" "MIRROR" "MOVE" "MSLIDE" "MSPACE" "MULTIPLE" 
  433.             "MVIEW" "NEW" "OFFSET" "OOPS" "OPEN" "ORTHO" "OSNAP" "PAN"
  434.             "PEDIT" "PFACE" "PLAN" "PLINE" "PLOT" "POINT" "POLYGON"
  435.             "PSOUT" "PSPACE" "PURGE" "PYRAMID" "QSAVE"
  436.             "QTEXT" "QUIT" "RECOVER" "REDEFINE" "REDO" "REDRAW" "REDRAWALL"
  437.             "REGEN" "REGENALL" "REGENAUTO" "REINIT" "RENAME" "RESUME" 
  438.             "REVSURF" "ROTATE" "RSCRIPT" "RULESURF" "SAVE" "SAVEAS" "SCALE"
  439.             "SCRIPT" "SELECT" "SETVAR" "SH" "SHADE" "SHAPE" "SHELL" "SKETCH"
  440.             "SNAP" "SOLID" "SPHERE" "STATUS" "STRETCH" "STYLE" "TABLET" "TABSURF"
  441.             "TEXT" "TEXTSCR" "TIME" "TORUS" "TRACE" "TREESTAT" "TRIM" "U" "UCS"
  442.             "UCSICON" "UNDEFINE" "UNDO" "UNITS" "VIEW" "VIEWPORTS" "VIEWRES"
  443.             "VPLAYER" "VPOINT" "VSLIDE" "WBLOCK" "WEDGE" "XBIND" "XREF" "ZOOM"
  444.             "3DFACE" "3DMESH" "3DPOLY"
  445.          )
  446.          index 0
  447.       )      
  448.  
  449.       (_addlisp)
  450.       (setq command_list(acad_strlsort command_list))
  451.  
  452.       (_stepthru)
  453.       (_update)
  454.  
  455.       (action_tile "accept" "(_accept)")
  456.       (action_tile "command" "(_command)")
  457.  
  458.       (start_list "command")
  459.       (foreach cmd command_list (add_list cmd))
  460.       (end_list)
  461.  
  462.       (set_tile "error" "")
  463.       (start_dialog)                                                      
  464.    )
  465.  
  466.    ;;
  467.    ;;Check and setup for function.
  468.    ;;
  469.    (cond
  470.       ((not(ai_transd)))                       ; transparent OK
  471.       ((not(ai_acadapp)))                      ; ACADAPP.EXP xloaded?
  472.       ((not(setq dcl_id(ai_dcl "ddalias"))))    ; is .DCL file loaded?
  473.       (t(if(and(/= 1(logand 1(getvar "cmdactive")))
  474.                (/= 8(logand 8(getvar "cmdactive")))
  475.             ) ;and
  476.             (ai_undo_push)
  477.          ) ;if
  478.          ;;
  479.          ;;Start function
  480.          ;;
  481.          (ddalias_main)
  482.          (if(and(/= 1(logand 1(getvar "cmdactive")))
  483.                (/= 8(logand 8(getvar "cmdactive")))
  484.             ) ;and
  485.             (ai_undo_pop)
  486.          ) ;if        
  487.       ) ;T
  488.    ) ;cond
  489.      (setvar "cmdecho" cmdecho)
  490.      (setq cmdecho nil)
  491.    (prin1)
  492. )   
  493.  
  494.  
  495.